home *** CD-ROM | disk | FTP | other *** search
/ The Original Shareware 1.1 / The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso / 19 / bix01.zip / USERIO.LIB < prev   
Text File  |  1986-07-07  |  7KB  |  239 lines
  1. {
  2.                  procedure and functions in this library
  3.  
  4.   WriteStr           write message out at (Col,Line)
  5.   Error              writes message out at (1,1), waits for character
  6.   GetChar            prompt user for one of a set of characters
  7.   Yes                asks user questions, waits for a Y/N answer
  8.   GetInteger         prompt user for an integer value in the range Min..Max
  9.   GrabInt            function version of GetInteger; used for subrange vars
  10.   WriteReal          write real value w/adjustable format
  11.   GetReal            prompt user for a real value in the range Min..Max
  12.   GetString          prompt user for a string
  13.   IOCheck            checks for I/O error; prints message if necessary
  14.  
  15. }
  16.  
  17. type
  18.   MsgStr             = string[80];
  19.   CharSet            = set of Char;
  20.  
  21. var
  22.   IOErr              : Boolean;
  23.   IOCode             : Integer;
  24.  
  25. procedure WriteStr(Col,Line : Integer; TStr : MsgStr);
  26. {
  27.        purpose       writes message out at spot indicated
  28.        last update   23 Jun 85
  29. }
  30. begin
  31.   GoToXY(Col,Line); ClrEol;
  32.   Write(TStr)
  33. end; { of proc WriteStr }
  34.  
  35. procedure Error(Msg : MsgStr);
  36. {
  37.        purpose       writes error message out at (1,1); waits for character
  38.        last update   05 Jul 85
  39. }
  40. const
  41.   Bell               = ^G;
  42. var
  43.   Ch                 : Char;
  44. begin
  45.   WriteStr(1,1,Msg+Bell+' (hit any key) ');
  46.   Read(Kbd,Ch)
  47. end; { of proc Error }
  48.  
  49. procedure GetChar(var Ch : Char; Prompt : MsgStr; OKSet : CharSet);
  50. {
  51.        purpose       let user enter command
  52.        last update   23 Jun 85
  53. }
  54. begin
  55.   WriteStr(1,1,Prompt);
  56.   repeat
  57.     Read(Kbd,Ch);
  58.     Ch := UpCase(Ch)
  59.   until Ch in OKSet;
  60.   WriteLn(Ch)
  61. end; { of proc GetChar }
  62.  
  63. function Yes(Question : MsgStr) : Boolean;
  64. {
  65.        purpose       asks user Y/N question
  66.        last update   03 Jul 85
  67. }
  68. var
  69.   Ch                 : Char;
  70. begin
  71.   GetChar(Ch,Question+' (Y/N) ',['Y','N']);
  72.   Yes := (Ch = 'Y')
  73. end; { of func Yes }
  74.  
  75. function GrabInt(Prompt : MsgStr; Min,Max : Integer) : Integer;
  76. {
  77.        purpose       prompts user for value in range Min..Max
  78.        note          you may not be able to pass subrange variables to
  79.                      GetInteger because of the difference in size.  In
  80.                      such cases, you can use GrabInt and directly assign
  81.                      the returned value to the subrange variable.
  82.        last update   05 Jul 85
  83. }
  84. var
  85.   Val                : Integer;
  86. begin
  87.   {$I-}
  88.   if Min > Max then begin
  89.     Val := Min;
  90.     Min := Max;
  91.     Max := Val
  92.   end;
  93.   repeat
  94.     WriteStr(1,1,Prompt);
  95.     Write(' [',Min,'..',Max,']:  ');
  96.     ReadLn(Val)
  97.   until (IOResult = 0) and (Min <= Val) and (Val <= Max);
  98.   GrabInt := Val
  99.   {$I+}
  100. end; { of proc GetInteger }
  101.  
  102. procedure GetInteger(var Val : Integer; Prompt : MsgStr; Min,Max : Integer);
  103. {
  104.        purpose       prompts user for value in range Min..Max
  105.        last update   22 June 1985
  106. }
  107. begin
  108.   Val := GrabInt(Prompt,Min,Max)
  109. end; { of proc GetInteger }
  110.  
  111. procedure WriteReal(RVal : Real; Width,Digits : Byte);
  112. {
  113.        purpose       decide which format to use based on magnitude
  114.        last update   10 Jul 85
  115. }
  116. const
  117.   Ln10               = 2.302585093;
  118. var
  119.   TVal               : Real;
  120.   Limit,Log          : Integer;
  121.  
  122.   procedure Condition(Min : Byte; var Val :Byte; Max : Byte);
  123.   begin
  124.     if Val < Min
  125.       then Val := Min
  126.     else if Val > Max
  127.       then Val := Max
  128.   end; { of local proc Condition }
  129.  
  130. begin
  131.   Condition(8,Width,80);
  132.   Condition(0,Digits,Width-3);
  133.   TVal := Abs(RVal);
  134.   Limit := (Width-Digits) - 1;
  135.   if RVal < 0.0
  136.     then Limit:= Limit - 1;
  137.   if TVal = 0.0
  138.     then Log := 0
  139.     else Log := Round(Ln(TVal)/Ln10);
  140.   if (Log < -Digits) or (Log >= Limit)
  141.     then Write(RVal:Width)
  142.     else Write(RVal:Width:Digits)
  143. end; { of proc WriteReal }
  144.  
  145. procedure GetReal(var Val : Real; Prompt : MsgStr; Min,Max : Real);
  146. {
  147.        purpose       prompts user for value in range Min..Max
  148.        last update   23 June 85
  149. }
  150. begin
  151.   {$I-}
  152.   repeat
  153.     WriteStr(1,1,Prompt+' [');
  154.     WriteReal(Min,8,4); Write('..'); WriteReal(Max,8,4);
  155.     Write(']:  '); ReadLn(Val);
  156.   until (IOResult = 0) and (Min <= Val) and (Val <= Max)
  157.   {$I+}
  158. end; { of proc GetReal }
  159.  
  160. procedure GetString(var NStr : MsgStr; Prompt : MsgStr; MaxLen : Integer;
  161.                     OKSet : CharSet);
  162. {
  163.        purpose       get string from user
  164.        last update   09 Jul 85
  165. }
  166. const
  167.   BS                 = ^H;
  168.   CR                 = ^M;
  169.   ConSet             : CharSet = [BS,CR];
  170. var
  171.   TStr               : MsgStr;
  172.   TLen,X             : Integer;
  173.   Ch                 : Char;
  174. begin
  175.   {$I-} { turn off I/O checking }
  176.   TStr := '';
  177.   TLen := 0;
  178.   WriteStr(1,1,Prompt);
  179.   X := 1 + Length(Prompt);
  180.   OKSet := OKSet + ConSet;
  181.   repeat
  182.     GoToXY(X,1);
  183.     repeat
  184.       Read(Kbd,Ch)
  185.     until Ch in OKSet;
  186.     if Ch = BS then begin
  187.       if TLen > 0 then begin
  188.         TLen := TLen - 1;
  189.         X := X - 1;
  190.         GoToXY(X,1); Write(' ');
  191.       end
  192.     end
  193.     else if (Ch <> CR) and (TLen < MaxLen) then begin
  194.       Write(Ch);
  195.       TLen := TLen + 1;
  196.       TStr[TLen] := Ch;
  197.       X := X + 1;
  198.     end
  199.   until Ch = CR;
  200.   if TLen > 0 then begin
  201.     TStr[0] := Chr(TLen);
  202.     NStr := TStr
  203.   end
  204.   else Write(NStr)
  205.   {$I+}
  206. end; { of proc GetString }
  207.  
  208. procedure IOCheck;
  209. {
  210.        purpose       check for IO error; print message if needed
  211.        last update   08 Jul 85
  212. }
  213. var
  214.   TStr               : string[4];
  215. begin
  216.   IOCode := IOResult;
  217.   IOErr  := (IOCode <> 0);
  218.   if IOErr then case IOCode of
  219.     $01  : Error('IOERROR> File does not exist');
  220.     $02  : Error('IOERROR> File not open for input');
  221.     $03  : Error('IOERROR> File not open for output');
  222.     $04  : Error('IOERROR> File not open');
  223.     $10  : Error('IOERROR> Error in numeric format');
  224.     $20  : Error('IOERROR> Operation not allowed on logical device');
  225.     $21  : Error('IOERROR> Not allowed in direct mode');
  226.     $22  : Error('IOERROR> Assign to standard files not allowed');
  227.     $90  : Error('IOERROR> Record length mismatch');
  228.     $91  : Error('IOERROR> Seek beyond end of file');
  229.     $99  : Error('IOERROR> Unexpected end of file');
  230.     $F0  : Error('IOERROR> Disk write error');
  231.     $F1  : Error('IOERROR> Directory is full');
  232.     $F2  : Error('IOERROR> File size overflow');
  233.     $FF  : Error('IOERROR> File disappeared')
  234.     else   Str(IOCode:3,TStr);
  235.            Error('IOERROR> Unknown I/O error:  '+TStr)
  236.   end
  237. end; { of proc IOCheck }
  238.  
  239.